home *** CD-ROM | disk | FTP | other *** search
/ Gigarom 1 / Gigarom Macintosh Archives (Quantum Leap)(CDRM1080320)(1993).iso / FILES / DEV / I-Z / Xlisp_Source.cpt / Animals.LSP < prev    next >
Lisp/Scheme  |  1985-10-21  |  11KB  |  752 lines
  1. (alloc 100) 
  2.  
  3. (expand 24) 
  4.  
  5.  
  6.  
  7.  
  8.  
  9. (setq hypotheses 
  10.  
  11.   '((animal is albatross) 
  12.  
  13.     (animal is penguin) 
  14.  
  15.     (animal is ostrich) 
  16.  
  17.     (animal is eagle) 
  18.  
  19.     (animal is apteryx) 
  20.  
  21.     (animal is zebra) 
  22.  
  23.     (animal is giraffe) 
  24.  
  25.     (animal is tiger) 
  26.  
  27.     (animal is cheetah) 
  28.  
  29.     (animal is squirrel) 
  30.  
  31.     (animal is chipmunk) 
  32.  
  33.     (animal is otter))) 
  34.  
  35.  
  36.  
  37.  
  38.  
  39.   
  40.  
  41. (setq baserules 
  42.  
  43.     '((rule identify1 
  44.  
  45.         (if (animal has hair)) 
  46.  
  47.         (then (animal is mammal))) 
  48.  
  49.     (rule identify2 
  50.  
  51.         (if (animal gives milk)) 
  52.  
  53.         (then (animal is mammal))) 
  54.  
  55.     (rule identify3 
  56.  
  57.         (if (animal has feathers)) 
  58.  
  59.         (then (animal is bird))) 
  60.  
  61.     (rule identify4 
  62.  
  63.         (if (animal lays eggs)) 
  64.  
  65.         (then (animal is bird))) 
  66.  
  67.     (rule identify5 
  68.  
  69.         (if (animal eats meat)) 
  70.  
  71.         (then (animal is carnivore))) 
  72.  
  73.     (rule identify6 
  74.  
  75.         (if (animal has pointed teeth) 
  76.  
  77.             (animal has claws) 
  78.  
  79.             (animal has forward eyes)) 
  80.  
  81.         (then (animal is carnivore))) 
  82.  
  83.     (rule identify7 
  84.  
  85.         (if (animal is mammal) 
  86.  
  87.             (animal has hooves)) 
  88.  
  89.         (then (animal is ungulate))) 
  90.  
  91.     (rule identify8 
  92.  
  93.          (if (animal is mammal) 
  94.  
  95.             (animal chews cud)) 
  96.  
  97.         (then (animal is ungulate) 
  98.  
  99.             (even toed))) 
  100.  
  101.     (rule identify9 
  102.  
  103.         (if (animal is mammal) 
  104.  
  105.             (animal is carnivore) 
  106.  
  107.             (animal has tawny color) 
  108.  
  109.             (animal has dark spots)) 
  110.  
  111.          (then (animal is cheetah))) 
  112.  
  113.     (rule identify10 
  114.  
  115.         (if (animal is mammal) 
  116.  
  117.             (animal is carnivore) 
  118.  
  119.             (animal has tawny color) 
  120.  
  121.             (animal has black stripes)) 
  122.  
  123.         (then (animal is tiger))) 
  124.  
  125.     (rule identify11 
  126.  
  127.          (if (animal is ungulate) 
  128.  
  129.             (animal has long neck) 
  130.  
  131.             (animal has long legs) 
  132.  
  133.             (animal has dark spots)) 
  134.  
  135.         (then (animal is giraffe))) 
  136.  
  137.     (rule identify12 
  138.  
  139.         (if (animal is ungulate) 
  140.  
  141.             (animal has black stripes)) 
  142.  
  143.         (then (animal is zebra))) 
  144.  
  145.     (rule identify13 
  146.  
  147.         (if (animal is bird) 
  148.  
  149.             (animal does not fly) 
  150.  
  151.             (animal has long neck) 
  152.  
  153.             (animal has long legs) 
  154.  
  155.             (animal is black and white)) 
  156.  
  157.         (then (animal is ostrich))) 
  158.  
  159.     (rule identify14 
  160.  
  161.         (if (animal is bird) 
  162.  
  163.             (animal does not fly) 
  164.  
  165.             (animal swims) 
  166.  
  167.             (animal is black and white)) 
  168.  
  169.         (then (animal is penguin))) 
  170.  
  171.     (rule identify15 
  172.  
  173.         (if (animal is bird) 
  174.  
  175.             (animal does not fly) 
  176.  
  177.             (animal has hair)) 
  178.  
  179.         (then (animal is apteryx))) 
  180.  
  181.     (rule identify19 
  182.  
  183.         (if (animal is bird) 
  184.  
  185.            (animal has long wings) 
  186.  
  187.            (animal flies at sea)) 
  188.  
  189.        (then (animal is albatross))) 
  190.  
  191.     (rule identify20 
  192.  
  193.         (if (animal is bird) 
  194.  
  195.            (animal has long wings) 
  196.  
  197.            (animal flies over land)) 
  198.  
  199.         (then (animal is eagle))) 
  200.  
  201.     (rule identify26 
  202.  
  203.         (if (animal is rodent) 
  204.  
  205.             (animal collects nuts) 
  206.  
  207.             (animal has striped tail)) 
  208.  
  209.         (then (animal is chipmunk))) 
  210.  
  211.     (rule identify27 
  212.  
  213.         (if (animal is rodent) 
  214.  
  215.             (animal collects nuts) 
  216.  
  217.             (animal has bushy tail)) 
  218.  
  219.         (then (animal is squirrel))) 
  220.  
  221.     (rule identify28 
  222.  
  223.         (if (animal is mammal) 
  224.  
  225.             (animal is small) 
  226.  
  227.             (animal has short legs)) 
  228.  
  229.         (then (animal is rodent))) 
  230.  
  231.     (rule identify32 
  232.  
  233.         (if (animal is mammal) 
  234.  
  235.             (animal is carnivore) 
  236.  
  237.             (animal swims) 
  238.  
  239.             (animal is slender) 
  240.  
  241.             (animal has brown fur)) 
  242.  
  243.         (then (animal is otter))))) 
  244.  
  245.  
  246.  
  247.  
  248.  
  249.  
  250.  
  251.  
  252.  
  253. (defun member (item s) 
  254.  
  255.     (cond ((null s) nil) 
  256.  
  257.           ((equal item (car s)) s) 
  258.  
  259.           (t (member item (cdr s))))) 
  260.  
  261.      
  262.  
  263. (defun remember (newfact truth reason) 
  264.  
  265.     (cond ((member newfact facts) nil) 
  266.  
  267.           (t (setq facts (cons newfact facts)) 
  268.  
  269.           (setq reasoning (cons (list truth reason) reasoning)) 
  270.  
  271.     newfact))) 
  272.  
  273.  
  274.  
  275.  
  276.  
  277. (defun recall (fact) 
  278.  
  279.     (cond ((member fact facts) fact) 
  280.  
  281.           (t nil))) 
  282.  
  283.  
  284.  
  285.  
  286.  
  287. (defun testif (rule ifs) 
  288.  
  289.     (setq ifs (car (cdr (cdr rule)))) 
  290.  
  291.     (while (&& (setq ifs (cdr ifs)) (recall (car ifs)))) 
  292.  
  293.     (null ifs)) 
  294.  
  295.  
  296.  
  297.  
  298.  
  299. (defun sayso (rule then) 
  300.  
  301.     (princ "\nRule ") 
  302.  
  303.     (print (car (cdr rule))) 
  304.  
  305.     (princ " deduces") 
  306.  
  307.     (prinlist then) 
  308.  
  309.     (princ "\n\n") 
  310.  
  311.     (setq success t)) 
  312.  
  313.        
  314.  
  315.       
  316.  
  317. (defun usethen (rule) 
  318.  
  319.     (setq success nil) 
  320.  
  321.     (setq thens (car (cdr (cdr (cdr rule))))) 
  322.  
  323.     (while (setq thens (cdr thens)) 
  324.  
  325.         (cond ((remember (car thens) t (car (cdr rule))) 
  326.  
  327.         (sayso rule (car thens))))) 
  328.  
  329.     success) 
  330.  
  331.      
  332.  
  333. (defun tryrule (rule) 
  334.  
  335.     (&& (testif rule nil) (usethen rule))) 
  336.  
  337.      
  338.  
  339.  
  340.  
  341.  
  342.  
  343. (defun testif+ (rule ifs) 
  344.  
  345.     (setq ifs (car (cdr (cdr rule)))) 
  346.  
  347.     (while (&& (setq ifs (cdr ifs)) (verify (car ifs) nil))) 
  348.  
  349.     (null ifs)) 
  350.  
  351.  
  352.  
  353.  
  354.  
  355.      
  356.  
  357. (defun tryrule+ (rule) 
  358.  
  359.     (&& (testif+ rule nil) (usethen rule))) 
  360.  
  361.      
  362.  
  363.  
  364.  
  365.  
  366.  
  367. (defun verify (fact relevant) 
  368.  
  369.     (cond ((recall fact) (car (findwhy fact))) 
  370.  
  371.        (t (setq relevant (inthen fact nil)) 
  372.  
  373.        (cond ((null relevant) (tryask fact)) 
  374.  
  375.          (t (trydeduce relevant)))))) 
  376.  
  377.  
  378.  
  379.  
  380.  
  381. (defun ask (fact) 
  382.  
  383.     (princ "Would you say that the") 
  384.  
  385.     (prinlist fact) 
  386.  
  387.     (princ "? ") 
  388.  
  389.     (getanswer)) 
  390.  
  391.  
  392.  
  393.  
  394.  
  395. (defun tryask (fact) 
  396.  
  397.     (setq answer (ask fact)) 
  398.  
  399.     (remember fact answer 'saidso) 
  400.  
  401.     answer) 
  402.  
  403.  
  404.  
  405.  
  406.  
  407. (defun dirdeduce (relrules) 
  408.  
  409.     (while (&& relrules 
  410.  
  411.                (! (tryrule (car relrules)))) 
  412.  
  413.                    (setq relrules (cdr relrules))) 
  414.  
  415.     relrules) 
  416.  
  417.      
  418.  
  419. (defun inddeduce (relrules) 
  420.  
  421.     (while (&& relrules 
  422.  
  423.                (! (tryrule+ (car relrules)))) 
  424.  
  425.                    (setq relrules (cdr relrules))) 
  426.  
  427.     relrules) 
  428.  
  429.      
  430.  
  431.      
  432.  
  433. (defun trydeduce (trelrules) 
  434.  
  435.     (cond ((dirdeduce trelrules) t) 
  436.  
  437.           ((inddeduce trelrules) t) 
  438.  
  439.           (t (cond (verbose  
  440.  
  441.               (princ "Assuming") 
  442.  
  443.               (prinlist fact) 
  444.  
  445.               (princ " to be untrue since it's unsupported.\n"))) 
  446.  
  447.    (remember fact nil 'exhausted) nil))) 
  448.  
  449.           
  450.  
  451. (defun thenp (fact rule) 
  452.  
  453.     (member fact (car (cdr (cdr (cdr rule)))))) 
  454.  
  455.  
  456.  
  457.  
  458.  
  459. (defun inthen (fact relrules) 
  460.  
  461.     (foreach rule baserules 
  462.  
  463.         (cond ((thenp fact rule) (setq relrules (cons rule relrules))))) 
  464.  
  465.      relrules) 
  466.  
  467.  
  468.  
  469.  
  470.  
  471.  
  472.  
  473.  
  474.  
  475. (setq Copyright-April-1985-Clive-Steward t)     
  476.  
  477.      
  478.  
  479. (defun docase () 
  480.  
  481.     (setq possibilities hypotheses) 
  482.  
  483.     (setq facts nil) 
  484.  
  485.     (setq reasoning nil) 
  486.  
  487.     (setq running nil) 
  488.  
  489.     (princ "\n\nAnimal expert at your service...\n\nWould you like ") 
  490.  
  491.     (princ "to be informed of progress as we work towards a result?") 
  492.  
  493.     (setq verbose (getanswer)) 
  494.  
  495.     (princ "\n") 
  496.  
  497.     (setq running t) 
  498.  
  499.     (while (&& (lookpossible) 
  500.  
  501.                (! (verify (car possibilities) nil))) 
  502.  
  503.        (setq possibilities (cdr possibilities))) 
  504.  
  505.     (setq running nil) 
  506.  
  507.     (cond ((null possibilities) (princ "\nNo hypothesis confirmed...\n\n")) 
  508.  
  509.           (t (princ "\n\nWhat you've told me indicates that the") 
  510.  
  511.               (prinlist (car possibilities)) 
  512.  
  513.               (princ ".\n\n") 
  514.  
  515.     (princ "Would you like an explanation? ") 
  516.  
  517.     (cond ((getanswer) (explain))))) 
  518.  
  519.     (cond (verbose (mem)))) 
  520.  
  521.  
  522.  
  523.  
  524.  
  525. (defun lookpossible () 
  526.  
  527.     (cond ((&& verbose possibilities) 
  528.  
  529.         (princ "Looking at possibility that") 
  530.  
  531.         (prinlist (car possibilities)) 
  532.  
  533.         (princ ".\n"))) 
  534.  
  535.     possibilities) 
  536.  
  537.              
  538.  
  539. (defun prinlist (plist) 
  540.  
  541.      (foreach x plist (princ " ") (princ x))) 
  542.  
  543.      
  544.  
  545. (defun findwhy (fact) 
  546.  
  547.     (setq findex 1) 
  548.  
  549.     (while (&& (setq curfact (nth findex facts)) 
  550.  
  551.               (! (equal fact curfact))) 
  552.  
  553.         (setq findex (+ 1 findex))) 
  554.  
  555.     (setq reason (nth findex reasoning))) 
  556.  
  557.      
  558.  
  559. (defun nl () (princ "\n")) 
  560.  
  561.  
  562.  
  563.  
  564.  
  565. (defun tab () (princ "    ")) 
  566.  
  567.  
  568.  
  569.  
  570.  
  571. (defun formatparts (element) 
  572.  
  573.      (tab) (princ (car element)) (nl) 
  574.  
  575.      (while (setq element (cdr element)) 
  576.  
  577.         (tab)(tab) (prinlist (car element)) 
  578.  
  579.      (nl))) 
  580.  
  581.  
  582.  
  583.  
  584.          
  585.  
  586. (defun formatrule (therule) 
  587.  
  588.      (prinlist (list (car therule) (nth 2 therule))) (princ ":") 
  589.  
  590.      (nl) (nl) 
  591.  
  592.      (formatparts (nth 3 therule)) 
  593.  
  594.      (formatparts (nth 4 therule))) 
  595.  
  596.  
  597.  
  598.  
  599.  
  600. (defun findrule (rule) 
  601.  
  602.      (setq frules baserules) 
  603.  
  604.      (while (&& frules (! (equal rule (car (cdr (car frules)))))) 
  605.  
  606.      (setq frules (cdr frules))) 
  607.  
  608.      (cond (frules (car frules)) 
  609.  
  610.           (t (princ "Error: no rule named ") 
  611.  
  612.               (princ rule) 
  613.  
  614.               (princ "!\n")))) 
  615.  
  616.  
  617.  
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  
  624. (defun explain () 
  625.  
  626.      (setq wantmore t)  
  627.  
  628.      (foreach fact facts 
  629.  
  630.           (cond (wantmore 
  631.  
  632.               (princ "\n") 
  633.  
  634.               (prinlist fact) 
  635.  
  636.               (setq reason (findwhy fact)) 
  637.  
  638.               (princ " is") 
  639.  
  640.               (cond ((car reason) (princ " true ")) 
  641.  
  642.                         (t (princ " false "))) 
  643.  
  644.               (cond ((equal (car (cdr reason)) 'saidso) 
  645.  
  646.                             (princ "because you said so.")) 
  647.  
  648.                         ((equal (car (cdr reason)) 'exhausted) 
  649.  
  650.                             (princ "because all rules which might prove it failed.")) 
  651.  
  652.                         (t (princ "because") 
  653.  
  654.                            (formatrule (findrule (car (cdr reason)))))) 
  655.  
  656.     (setq running nil) 
  657.  
  658.     (princ "\n\nDo you want further explanation? ") 
  659.  
  660.     (setq wantmore (getanswer)) 
  661.  
  662.     (princ "\n"))))) 
  663.  
  664.  
  665.  
  666.  
  667.  
  668. (defun getanswer () 
  669.  
  670.     (setq answ (read)) 
  671.  
  672.     (cond ((member answ legalanswers) (eval (list answ))) 
  673.  
  674.                (t (princ "\nSorry, legal answers are ") 
  675.  
  676.                    (princ ": ") 
  677.  
  678.                    (prinlist legalanswers) 
  679.  
  680.                    (princ ".  Please respond again --") 
  681.  
  682.                    (getanswer)))) 
  683.  
  684.  
  685.  
  686.  
  687.  
  688. (setq legalanswers '(yes no why)) 
  689.  
  690.  
  691.  
  692.  
  693.  
  694. (defun no () nil) 
  695.  
  696.  
  697.  
  698.  
  699.  
  700. (defun yes () t) 
  701.  
  702.  
  703.  
  704.  
  705.          
  706.  
  707. (defun why () 
  708.  
  709.      (cond (running 
  710.  
  711.          (princ "\nBecause I'm trying to establish") 
  712.  
  713.              (formatrule rule) 
  714.  
  715.              (princ "\n\n") 
  716.  
  717.              (ask fact)) 
  718.  
  719.         (t (princ "\nSorry, why is useful only when I've ") 
  720.  
  721.              (princ "asked you for a fact....\n\n") 
  722.  
  723.              (princ "Please answer again --") 
  724.  
  725.              (getanswer)))) 
  726.  
  727.  
  728.  
  729.  
  730.  
  731. (defun consult () 
  732.  
  733.     (setq runcase t) 
  734.  
  735.     (while runcase 
  736.  
  737.        (docase) 
  738.  
  739.        (princ "\n\nWould you like to try another case? ") 
  740.  
  741.        (setq runcase (getanswer)))) 
  742.  
  743.  
  744.  
  745.  
  746.          
  747.  
  748. (consult) 
  749.  
  750.  
  751.  
  752.